home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0059_Plasma.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  4KB  |  179 lines
  1. {$G+} { Enable 286 Instructions }
  2. {$N+} { Enable Math Coprocessor - Delete This Line If You Don't Have One }
  3. Program FractalPlasma;
  4.  
  5. { Programmed By David Dahl }
  6.  
  7. (* PUBLIC DOMAIN *)
  8.  
  9. Uses
  10.   CRT,
  11.   Palette;
  12.  
  13. Const
  14.   Rug = 0.2;
  15.  
  16. Type
  17.   VGAPtr  = ^VGAType;
  18.   VGAType = Array [0..199, 0..319] of Byte;
  19.  
  20. Var
  21.   Screen    : VGAPtr;
  22.  
  23.   PlasmaMap : VGAPtr;
  24.   PlasmaPal : PaletteType;
  25.  
  26. Procedure GeneratePlasma(P : VGAPtr);
  27. {                                                                 }
  28. { This procedure uses an algorithm to generate a fractal surface. }
  29. {                                                                 }
  30. { Algorithm from page 359 of _Computer_Graphics:_the_Principles_  }
  31. { _Behind_the_Art_And_Science_ by Pokorny and Gerald.             }
  32. {                                                                 }
  33.   Procedure FractPlasma(il, jl, ih, jh : Integer);
  34.   Var
  35.     im, jm : Integer;
  36.   Begin
  37.     im := (il + ih + 1) DIV 2;
  38.     jm := (jl + jh + 1) DIV 2;
  39.  
  40.     If jm < jh then
  41.     Begin
  42.       If P^[il,jm] = 0 Then
  43.         P^[il,jm] := Trunc(((P^[il,jl] + P^[il,jh]) / 2) +
  44.                               Random*Rug*(jh-jl));
  45.       If il < ih Then
  46.         P^[ih,jm] := Trunc(((P^[ih,jl] + P^[ih,jh]) / 2) +
  47.                               Random*Rug*(jh-jl));
  48.     End;
  49.  
  50.     If im < ih then
  51.     Begin
  52.       If P^[im,jl] = 0 Then
  53.         P^[im,jl] := Trunc(((P^[il,jl] + P^[ih,jl]) / 2) +
  54.                               Random*Rug*(ih-il));
  55.       If jl < jh Then
  56.         P^[im,jh] := Trunc(((P^[il,jh] + P^[ih,jh]) / 2) +
  57.                               Random*Rug*(jh-jl));
  58.     End;
  59.  
  60.     If (im < ih) AND (jm < jh) Then
  61.       P^[im,jm] := Trunc(((P^[il,jl] + P^[ih,jl] +
  62.                            P^[il,jh] + P^[ih, jh]) / 4) +
  63.                            Random*Rug*(ABS(ih-il)+abs(jh-jl)));
  64.     If (im < ih) OR (jm < jh) Then
  65.     Begin
  66.       FractPlasma(il, jl, im, jm);
  67.       FractPlasma(il, jm, im, jh);
  68.       FractPlasma(im, jl, ih, jm);
  69.       FractPlasma(im, jm, ih, jh);
  70.     End;
  71.   End;
  72.  
  73. Begin
  74.   FractPlasma(0, 0, 199, 319);
  75. End;
  76.  
  77. Procedure InitVGA13h; Assembler;
  78. Asm
  79.   MOV AX, $0013
  80.   INT $10
  81. End;
  82.  
  83. Procedure CalculatePalette(Var PalOut : PaletteType);
  84. Var
  85.   RA, GA, BA : Integer;
  86.   RF, GF, BF : Integer;
  87.   RS, GS, BS : Integer;
  88.   Counter    : Word;
  89. Begin
  90.   RA := 16 + Random(32-16);
  91.   GA := 16 + Random(32-16);
  92.   BA := 16 + Random(32-16);
  93.  
  94.   RF := 2 + Random(5);
  95.   GF := 2 + Random(5);
  96.   BF := 2 + Random(5);
  97.  
  98.   RS := Random(64);
  99.   GS := Random(64);
  100.   BS := Random(64);
  101.  
  102.  
  103.   For Counter := 0 to 255 do
  104.   With PalOut[Counter] do
  105.   Begin
  106.     Red   := 32 + Round(RA * Sin((RS + Counter * RF) * Pi / 128));
  107.     Green := 32 + Round(GA * Sin((GS + Counter * GF) * Pi / 128));
  108.     Blue  := 32 + Round(BA * Sin((BS + Counter * BF) * Pi / 128));
  109.   End;
  110. End;
  111.  
  112. Procedure RotatePalette(Var PalIn : PaletteType);
  113. Var
  114.   TRGB : PaletteRec;
  115. Begin
  116.   TRGB := PalIn[0];
  117.   Move (PalIn[1], PalIn[0], 255 * 3);
  118.   PalIn[255] := TRGB;
  119. End;
  120.  
  121. Var
  122.   Int : Integer;
  123.   Key : Char;
  124. Begin
  125.   DirectVideo := False;
  126.   Randomize;
  127.  
  128.   InitVGA13h;
  129.  
  130.   Screen := Ptr($A000,$0000);
  131.   New(PlasmaMap);
  132.  
  133.   { Initialize Workspace }
  134.   FillChar(PlasmaMap^, 320 * 200 , 0);
  135.  
  136.   { Calculate Smooth Random Colors }
  137.   CalculatePalette(PlasmaPal);
  138.  
  139.   GotoXY(12, 12);
  140.   Writeln('Generating Plasma');
  141.   GotoXY(14, 14);
  142.   Writeln('Please Wait...');
  143.  
  144.   GeneratePlasma(PlasmaMap);
  145.  
  146.   { Set All Colors to Black }
  147.   BlackPalette;
  148.   { Copy Fractal To Screen }
  149.   Screen^ := PlasmaMap^;
  150.  
  151.   { Rotate Palette And Fade It In Slowly }
  152.   For Int := 1 to 32 do
  153.   Begin
  154.     RotatePalette(PlasmaPal);
  155.     FadeInFromBlackQ(PlasmaPal, Int);
  156.   End;
  157.  
  158.   { Rotate Full Intensity Palette And Wait For KeyPress }
  159.   Repeat
  160.     RotatePalette(PlasmaPal);
  161.     SetPalette(PlasmaPal);
  162.   Until KeyPressed;
  163.  
  164.   { Rotate Palette and Fade It Out Slowly }
  165.   For Int := 31 downto 0 do
  166.   Begin
  167.     RotatePalette(PlasmaPal);
  168.     FadeInFromBlackQ(PlasmaPal, Int);
  169.   End;
  170.  
  171.   Dispose(PlasmaMap);
  172.  
  173.   TextMode(C80);
  174.  
  175.   { Flush Keyboard Buffer }
  176.   While KeyPressed do
  177.     Key := ReadKey;
  178. End.
  179.